R Graphics Cookbook Chapter 13
Mitch Holman
2018-04-25
library(ggplot2)
library(gcookbook)
library(corrplot)## corrplot 0.84 loadedlibrary(igraph)##
## Attaching package: 'igraph'## The following objects are masked from 'package:stats':
##
## decompose, spectrum## The following object is masked from 'package:base':
##
## unionlibrary(rgl)## Warning in rgl.init(initValue, onlyNULL): RGL: unable to open X11 display## Warning: 'rgl_init' failed, running with rgl.useNULL = TRUElibrary(grid)
library(vcd)
library(MASS)
library(maps)
library(plyr)##
## Attaching package: 'plyr'## The following object is masked from 'package:maps':
##
## ozonelibrary(maptools)## Loading required package: sp## Checking rgeos availability: TRUEMiscellaneous Graphs
Note: Some problems cannot be completed as written because the code has changed. You will need to find the updated code.
Section 13.1. Making a Correlation Matrix
mcor <- cor(mtcars)
corrplot(mcor)
corrplot(mcor, method="shade", shade.col=NA, tl.col="black", tl.srt=45)
col <- colorRampPalette(c("#BB4444", "#EE9988", "#FFFFFF", "#77AADD", "#4477AA"))
corrplot(mcor, method="shade", shade.col=NA, tl.col="black", tl.srt=45, col=col(200), addCoef.col="black", addcolorlabel="no", order="AOE")## Warning in text.default(pos.xlabel[, 1], pos.xlabel[, 2], newcolnames, srt
## = tl.srt, : "addcolorlabel" is not a graphical parameter## Warning in text.default(pos.ylabel[, 1], pos.ylabel[, 2], newrownames, col
## = tl.col, : "addcolorlabel" is not a graphical parameter## Warning in title(title, ...): "addcolorlabel" is not a graphical parameter
Section 13.2. Plotting a Function
p <- ggplot(data.frame(x=c(-3,3)), aes(x=x))
p + stat_function(fun = dnorm)
p + stat_function(fun=dt, args=list(df=2))
myfun <- function(xvar) {
1/(1 + exp(-xvar + 10))
}
ggplot(data.frame(x=c(0, 20)), aes(x=x)) + stat_function(fun=myfun)
limitRange <- function(fun, min, max) {
function(x) {
y <- fun(x)
y[x < min | x > max] <- NA
return(y)
}
}
p + stat_function(fun = dnorm) +
stat_function(fun = limitRange(dnorm, 0, 2),
geom="area", fill="blue", alpha=0.2)
Section 13.3. Shading a Subregion Under a Function Curve
gd <- graph(c(1,2, 2,3, 2,4, 1,4, 5,5, 3,6))
plot(gd)
gu <- graph(c(1,2, 2,3, 2,4, 1,4, 5,5, 3,6), directed=FALSE)
plot(gu, vertex.label=NA)
set.seed(229)
plot(gu)
g <- graph.data.frame(madmen2, directed=TRUE)
par(mar=c(0,0,0,0))
plot(g, layout=layout.fruchterman.reingold, vertex.size=8, edge.arrow.size=0.5,
vertex.label=NA)
g <- graph.data.frame(madmen, directed=FALSE)
par(mar=c(0,0,0,0))
plot(g, layout=layout.circle, vertex.size=8, vertex.label=NA)
Section 13.4. Creating a Network Graph
gd <- graph(c(1,2, 2,3, 2,4, 1,4, 5,5, 3,6))
plot(gd)
gu <- graph(c(1,2, 2,3, 2,4, 1,4, 5,5, 3,6), directed=FALSE)
plot(gu, vertex.label=NA)
g <- graph.data.frame(madmen2, directed=TRUE)
par(mar=c(0,0,0,0))
plot(g, layout=layout.fruchterman.reingold, vertex.size=8, edge.arrow.size=0.5,
vertex.label=NA)
g <- graph.data.frame(madmen, directed=FALSE)
par(mar=c(0,0,0,0))
plot(g, layout=layout.circle, vertex.size=8, vertex.label=NA)
Section 13.5. Using Text Labels in a Network Graph
m <- madmen[1:nrow(madmen) %% 2 == 1, ]
g <- graph.data.frame(m, directed=FALSE)
V(g)$name## [1] "Betty Draper" "Don Draper" "Harry Crane"
## [4] "Joan Holloway" "Lane Pryce" "Peggy Olson"
## [7] "Pete Campbell" "Roger Sterling" "Sal Romano"
## [10] "Henry Francis" "Allison" "Candace"
## [13] "Faye Miller" "Megan Calvet" "Rachel Menken"
## [16] "Suzanne Farrell" "Hildy" "Franklin"
## [19] "Rebecca Pryce" "Abe Drexler" "Duck Phillips"
## [22] "Playtex bra model" "Ida Blankenship" "Mirabelle Ames"
## [25] "Vicky" "Kitty Romano"plot(g, layout=layout.fruchterman.reingold,
vertex.size = 4,
vertex.label = V(g)$name,
vertex.label.cex = 0.8,
vertex.label.dist = 0.4,
vertex.label.color = "black")
V(g)$size <- 4
V(g)$label <- V(g)$name
V(g)$label.cex <- 0.8
V(g)$label.dist <- 0.4
V(g)$label.color <- "black"
g$layout <- layout.fruchterman.reingold
plot(g)
E(g)## + 20/20 edges from 81084af (vertex names):
## [1] Betty Draper --Henry Francis Don Draper --Allison
## [3] Betty Draper --Don Draper Don Draper --Candace
## [5] Don Draper --Faye Miller Don Draper --Megan Calvet
## [7] Don Draper --Rachel Menken Don Draper --Suzanne Farrell
## [9] Harry Crane --Hildy Joan Holloway --Franklin
## [11] Joan Holloway --Roger Sterling Lane Pryce --Rebecca Pryce
## [13] Peggy Olson --Abe Drexler Peggy Olson --Duck Phillips
## [15] Peggy Olson --Pete Campbell Pete Campbell --Playtex bra model
## [17] Roger Sterling--Ida Blankenship Roger Sterling--Mirabelle Ames
## [19] Roger Sterling--Vicky Sal Romano --Kitty RomanoE(g)[c(2,11,19)]$label <- "M"
E(g)$color <- "grey70"
E(g)[c(2,11,19)]$color <- "red"
plot(g)
Section 13.6. Creating a Heat Map
pres_rating <- data.frame(
rating = as.numeric(presidents),
year = as.numeric(floor(time(presidents))),
quarter = as.numeric(cycle(presidents))
)
pres_rating## rating year quarter
## 1 NA 1945 1
## 2 87 1945 2
## 3 82 1945 3
## 4 75 1945 4
## 5 63 1946 1
## 6 50 1946 2
## 7 43 1946 3
## 8 32 1946 4
## 9 35 1947 1
## 10 60 1947 2
## 11 54 1947 3
## 12 55 1947 4
## 13 36 1948 1
## 14 39 1948 2
## 15 NA 1948 3
## 16 NA 1948 4
## 17 69 1949 1
## 18 57 1949 2
## 19 57 1949 3
## 20 51 1949 4
## 21 45 1950 1
## 22 37 1950 2
## 23 46 1950 3
## 24 39 1950 4
## 25 36 1951 1
## 26 24 1951 2
## 27 32 1951 3
## 28 23 1951 4
## 29 25 1952 1
## 30 32 1952 2
## 31 NA 1952 3
## 32 32 1952 4
## 33 59 1953 1
## 34 74 1953 2
## 35 75 1953 3
## 36 60 1953 4
## 37 71 1954 1
## 38 61 1954 2
## 39 71 1954 3
## 40 57 1954 4
## 41 71 1955 1
## 42 68 1955 2
## 43 79 1955 3
## 44 73 1955 4
## 45 76 1956 1
## 46 71 1956 2
## 47 67 1956 3
## 48 75 1956 4
## 49 79 1957 1
## 50 62 1957 2
## 51 63 1957 3
## 52 57 1957 4
## 53 60 1958 1
## 54 49 1958 2
## 55 48 1958 3
## 56 52 1958 4
## 57 57 1959 1
## 58 62 1959 2
## 59 61 1959 3
## 60 66 1959 4
## 61 71 1960 1
## 62 62 1960 2
## 63 61 1960 3
## 64 57 1960 4
## 65 72 1961 1
## 66 83 1961 2
## 67 71 1961 3
## 68 78 1961 4
## 69 79 1962 1
## 70 71 1962 2
## 71 62 1962 3
## 72 74 1962 4
## 73 76 1963 1
## 74 64 1963 2
## 75 62 1963 3
## 76 57 1963 4
## 77 80 1964 1
## 78 73 1964 2
## 79 69 1964 3
## 80 69 1964 4
## 81 71 1965 1
## 82 64 1965 2
## 83 69 1965 3
## 84 62 1965 4
## 85 63 1966 1
## 86 46 1966 2
## 87 56 1966 3
## 88 44 1966 4
## 89 44 1967 1
## 90 52 1967 2
## 91 38 1967 3
## 92 46 1967 4
## 93 36 1968 1
## 94 49 1968 2
## 95 35 1968 3
## 96 44 1968 4
## 97 59 1969 1
## 98 65 1969 2
## 99 65 1969 3
## 100 56 1969 4
## 101 66 1970 1
## 102 53 1970 2
## 103 61 1970 3
## 104 52 1970 4
## 105 51 1971 1
## 106 48 1971 2
## 107 54 1971 3
## 108 49 1971 4
## 109 49 1972 1
## 110 61 1972 2
## 111 NA 1972 3
## 112 NA 1972 4
## 113 68 1973 1
## 114 44 1973 2
## 115 40 1973 3
## 116 27 1973 4
## 117 28 1974 1
## 118 25 1974 2
## 119 24 1974 3
## 120 24 1974 4p <- ggplot(pres_rating, aes(x=year, y=quarter, fill=rating))
p + geom_tile()
p + geom_raster()
p + geom_tile() +
scale_x_continuous(breaks = seq(1940, 1976, by = 4)) +
scale_y_reverse() +
scale_fill_gradient2(midpoint=50, mid="grey70", limits=c(0,100))
Section 13.7. Creating a Three-Dimensional Scatter Plot
plot3d(mtcars$wt, mtcars$disp, mtcars$mpg, type="s", size=0.75, lit=FALSE)
interleave <- function(v1, v2) as.vector(rbind(v1,v2))
plot3d(mtcars$wt, mtcars$disp, mtcars$mpg,
xlab="Weight", ylab="Displacement", zlab="MPG",
size=.75, type="s", lit=FALSE)
segments3d(interleave(mtcars$wt, mtcars$wt),
interleave(mtcars$disp, mtcars$disp),
interleave(mtcars$mpg, min(mtcars$mpg)),
alpha=0.4, col="blue")
plot3d(mtcars$wt, mtcars$disp, mtcars$mpg,
xlab = "", ylab = "", zlab = "",
axes = FALSE,
size=.75, type="s", lit=FALSE)
segments3d(interleave(mtcars$wt, mtcars$wt),
interleave(mtcars$disp, mtcars$disp),
interleave(mtcars$mpg, min(mtcars$mpg)),
alpha = 0.4, col = "blue")
rgl.bbox(color="grey50",
emission="grey50",
xlen=0, ylen=0, zlen=0)
rgl.material(color="black")
axes3d(edges=c("x--", "y+-", "z--"),
ntick=6,
cex=.75)
mtext3d("Weight", edge="x--", line=2)
mtext3d("Displacement", edge="y+-", line=3)
mtext3d("MPG", edge="z--", line=3)Section 13.8. Adding a Prediction Surface to a Three-Dimensional Plot
predictgrid <- function(model, xvar, yvar, zvar, res = 16, type = NULL) {
xrange <- range(model$model[[xvar]])
yrange <- range(model$model[[yvar]])
newdata <- expand.grid(x = seq(xrange[1], xrange[2], length.out = res),
y = seq(yrange[1], yrange[2], length.out = res))
names(newdata) <- c(xvar, yvar)
newdata[[zvar]] <- predict(model, newdata = newdata, type = type)
newdata
}
df2mat <- function(p, xvar = NULL, yvar = NULL, zvar = NULL) {
if (is.null(xvar)) xvar <- names(p)[1]
if (is.null(yvar)) yvar <- names(p)[2]
if (is.null(zvar)) zvar <- names(p)[3]
x <- unique(p[[xvar]])
y <- unique(p[[yvar]])
z <- matrix(p[[zvar]], nrow = length(y), ncol = length(x))
m <- list(x, y, z)
names(m) <- c(xvar, yvar, zvar)
m
}
interleave <- function(v1, v2) as.vector(rbind(v1,v2))
m <- mtcars
mod <- lm(mpg ~ wt + disp + wt:disp, data = m)
m$pred_mpg <- predict(mod)
mpgrid_df <- predictgrid(mod, "wt", "disp", "mpg")
mpgrid_list <- df2mat(mpgrid_df)
plot3d(m$wt, m$disp, m$mpg, type="s", size=0.5, lit=FALSE)
spheres3d(m$wt, m$disp, m$pred_mpg, alpha=0.4, type="s", size=0.5, lit=FALSE)
segments3d(interleave(m$wt, m$wt),
interleave(m$disp, m$disp),
interleave(m$mpg, m$pred_mpg),
alpha=0.4, col="red")
surface3d(mpgrid_list$wt, mpgrid_list$disp, mpgrid_list$mpg,
alpha=0.4, front="lines", back="lines")spheres3d(m$wt, m$disp, m$pred_mpg, alpha=0.4, type="s", size=0.5, lit=FALSE)
segments3d(interleave(m$wt, m$wt),
interleave(m$disp, m$disp),
interleave(m$mpg, m$pred_mpg),
alpha=0.4, col="red")
surface3d(mpgrid_list$wt, mpgrid_list$disp, mpgrid_list$mpg,
alpha=0.4, front="lines", back="lines")
rgl.bbox(color="grey50",
emission="grey50",
xlen=0, ylen=0, zlen=0)
rgl.material(color="black")
axes3d(edges=c("x--", "y+-", "z--"),
ntick=6,
cex=.75)
mtext3d("Weight", edge="x--", line=2)
mtext3d("Displacement", edge="y+-", line=3)
mtext3d("MPG", edge="z--", line=3)Section 13.11. Creating a Dendrogram
c2 <- subset(countries, Year==2009)
c2 <- c2[complete.cases(c2), ]
set.seed(201)
c2 <- c2[sample(1:nrow(c2), 25), ]
c2## Name Code Year GDP laborrate healthexp
## 6731 Mongolia MNG 2009 1690.4170 72.9 74.19826
## 1733 Canada CAN 2009 39599.0418 67.8 4379.76084
## 4028 Guatemala GTM 2009 2684.9664 66.9 186.12313
## 611 Austria AUT 2009 45555.4345 60.4 5037.31089
## 10964 Zambia ZMB 2009 1006.3882 69.2 47.05637
## 1478 Bulgaria BGR 2009 6403.1477 54.5 474.84637
## 662 Azerbaijan AZE 2009 4808.1688 63.0 284.72528
## 3824 Greece GRC 2009 28936.4809 53.7 3040.73383
## 1070 Benin BEN 2009 771.7088 72.7 31.92885
## 2957 Egypt, Arab Rep. EGY 2009 2370.7111 48.8 113.29717
## 4844 Italy ITA 2009 35073.3225 49.1 3327.62987
## 7037 Nepal NPL 2009 438.1784 71.5 25.34454
## 6119 Malaysia MYS 2009 6908.6611 62.0 336.43858
## 4793 Israel ISR 2009 26102.3506 57.1 1966.47189
## 5252 Korea, Rep. KOR 2009 17109.9851 60.9 1107.94833
## 5099 Kenya KEN 2009 744.4031 82.2 33.24912
## 152 Algeria DZA 2009 4022.1989 58.5 267.94653
## 2447 Croatia HRV 2009 14322.6081 53.0 1120.37109
## 5609 Lesotho LSO 2009 800.4202 74.0 70.04993
## 4691 Ireland IRL 2009 49737.9274 63.6 4951.84469
## 7343 Nigeria NGA 2009 1091.1344 56.2 69.29737
## 5660 Liberia LBR 2009 229.2703 71.1 29.35613
## 5558 Lebanon LBN 2009 8321.3707 46.1 663.27358
## 5966 Macedonia, FYR MKD 2009 4510.2380 54.0 313.68971
## 10148 Turkmenistan TKM 2009 3710.4536 68.0 77.06955
## infmortality
## 6731 27.8
## 1733 5.2
## 4028 25.9
## 611 3.6
## 10964 71.5
## 1478 11.1
## 662 41.1
## 3824 3.5
## 1070 74.7
## 2957 20.0
## 4844 3.2
## 7037 43.3
## 6119 5.6
## 4793 3.7
## 5252 4.3
## 5099 56.3
## 152 32.0
## 2447 4.9
## 5609 67.0
## 4691 3.4
## 7343 90.4
## 5660 77.6
## 5558 19.4
## 5966 10.6
## 10148 48.0rownames(c2) <- c2$Name
c2 <- c2[,4:7]
c2## GDP laborrate healthexp infmortality
## Mongolia 1690.4170 72.9 74.19826 27.8
## Canada 39599.0418 67.8 4379.76084 5.2
## Guatemala 2684.9664 66.9 186.12313 25.9
## Austria 45555.4345 60.4 5037.31089 3.6
## Zambia 1006.3882 69.2 47.05637 71.5
## Bulgaria 6403.1477 54.5 474.84637 11.1
## Azerbaijan 4808.1688 63.0 284.72528 41.1
## Greece 28936.4809 53.7 3040.73383 3.5
## Benin 771.7088 72.7 31.92885 74.7
## Egypt, Arab Rep. 2370.7111 48.8 113.29717 20.0
## Italy 35073.3225 49.1 3327.62987 3.2
## Nepal 438.1784 71.5 25.34454 43.3
## Malaysia 6908.6611 62.0 336.43858 5.6
## Israel 26102.3506 57.1 1966.47189 3.7
## Korea, Rep. 17109.9851 60.9 1107.94833 4.3
## Kenya 744.4031 82.2 33.24912 56.3
## Algeria 4022.1989 58.5 267.94653 32.0
## Croatia 14322.6081 53.0 1120.37109 4.9
## Lesotho 800.4202 74.0 70.04993 67.0
## Ireland 49737.9274 63.6 4951.84469 3.4
## Nigeria 1091.1344 56.2 69.29737 90.4
## Liberia 229.2703 71.1 29.35613 77.6
## Lebanon 8321.3707 46.1 663.27358 19.4
## Macedonia, FYR 4510.2380 54.0 313.68971 10.6
## Turkmenistan 3710.4536 68.0 77.06955 48.0c3 <- scale(c2)
hc <- hclust(dist(c3))
plot(hc)
plot(hc, hang = -1)
Section 13.12. Creating a Vector Field
islice <- subset(isabel, z == min(z))
ggplot(islice, aes(x=x, y=y)) +
geom_segment(aes(xend = x + vx/50, yend = y + vy/50),
size = 0.25) ## Warning: Removed 3745 rows containing missing values (geom_segment).
islice <- subset(isabel, z == min(z))
every_n <- function(x, by = 2) {
x <- sort(x)
x[seq(1, length(x), by = by)]
}
keepx <- every_n(unique(isabel$x), by=4)
keepy <- every_n(unique(isabel$y), by=4)
islicesub <- subset(islice, x %in% keepx & y %in% keepy)
ggplot(islicesub, aes(x=x, y=y)) +
geom_segment(aes(xend = x+vx/50, yend = y+vy/50),
arrow = arrow(length = unit(0.1, "cm")), size =0.25)## Warning: Removed 248 rows containing missing values (geom_segment).
islicesub$speedxy <- sqrt(islicesub$vx^2 + islicesub$vy^2)
ggplot(islicesub, aes(x=x, y=y)) +
geom_segment(aes(xend = x+vx/50, yend = y+vy/50, alpha = speed),
arrow = arrow(length = unit(0.1,"cm")), size = 0.6)## Warning: Removed 248 rows containing missing values (geom_segment).
usa <- map_data("usa")
ggplot(islicesub, aes(x=x, y=y)) +
geom_segment(aes(xend = x+vx/50, yend = y+vy/50, colour = speed),
arrow = arrow(length = unit(0.1,"cm")), size = 0.6) +
scale_colour_continuous(low="grey80", high="darkred") +
geom_path(aes(x=long, y=lat, group=group), data=usa) +
coord_cartesian(xlim = range(islicesub$x), ylim = range(islicesub$y))## Warning: Removed 248 rows containing missing values (geom_segment).
keepx <- every_n(unique(isabel$x), by=5)
keepy <- every_n(unique(isabel$y), by=5)
keepz <- every_n(unique(isabel$z), by=2)
isub <- subset(isabel, x %in% keepx & y %in% keepy & z %in% keepz)
ggplot(isub, aes(x=x, y=y)) +
geom_segment(aes(xend = x+vx/50, yend = y+vy/50, colour = speed),
arrow = arrow(length = unit(0.1,"cm")), size = 0.5) +
scale_colour_continuous(low="grey80", high="darkred") +
facet_wrap( ~ z)## Warning: Removed 151 rows containing missing values (geom_segment).
Section 13.13. Creating a QQ Plot
qqnorm(heightweight$heightIn)
qqline(heightweight$heightIn)
qnorm(heightweight$ageYear)## Warning in qnorm(heightweight$ageYear): NaNs produced## [1] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [18] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [35] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [52] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [69] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [86] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [103] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [120] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [137] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [154] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [171] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [188] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [205] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN
## [222] NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaN NaNqqline(heightweight$ageYear)
Section 13.14. Creating a Plot of an Empirical Cumulative Distribution Function
ggplot(heightweight, aes(x=heightIn)) + stat_ecdf()
ggplot(heightweight, aes(x=ageYear)) + stat_ecdf()
mosaic( ~ Dept + Gender + Admit, data=UCBAdmissions,
highlighting="Admit", highlighting_fill=c("lightblue", "pink"),
direction=c("v","h","v"))
mosaic( ~ Dept + Gender + Admit, data=UCBAdmissions,
highlighting="Admit", highlighting_fill=c("lightblue", "pink"),
direction=c("v", "v", "h"))
mosaic( ~ Dept + Gender + Admit, data=UCBAdmissions,
highlighting="Admit", highlighting_fill=c("lightblue", "pink"),
direction=c("v", "h", "h"))
Section 13.15. Creating a Mosaic Plot
mosaic( ~ Admit + Gender + Dept, data=UCBAdmissions)
Section 13.16. Creating a Pie Chart
fold <- table(survey$Fold)
fold##
## L on R Neither R on L
## 99 18 120pie(fold)
pie(c(99, 18, 120), labels=c("L on R", "Neither", "R on L"))
Section 13.17. Creating a Map
states_map <- map_data("state")
ggplot(states_map, aes(x=long, y=lat, group=group)) +
geom_polygon(fill="white", colour="black")
ggplot(states_map, aes(x=long, y=lat, group=group)) +
geom_path() + coord_map("mercator")
east_asia <- map_data("world", region=c("Japan", "China", "North Korea",
"South Korea"))
ggplot(east_asia, aes(x=long, y=lat, group=group, fill=region)) +
geom_polygon(colour="black") +
scale_fill_brewer(palette="Set2")
nz1 <- map_data("world", region="New Zealand")
nz1 <- subset(nz1, long > 0 & lat > -48)
ggplot(nz1, aes(x=long, y=lat, group=group)) + geom_path()
nz2 <- map_data("nz")
ggplot(nz2, aes(x=long, y=lat, group=group)) + geom_path()
Section 13.18. Creating a Chloropleth Map
crimes <- data.frame(state = tolower(rownames(USArrests)), USArrests)
crimes## state Murder Assault UrbanPop Rape
## Alabama alabama 13.2 236 58 21.2
## Alaska alaska 10.0 263 48 44.5
## Arizona arizona 8.1 294 80 31.0
## Arkansas arkansas 8.8 190 50 19.5
## California california 9.0 276 91 40.6
## Colorado colorado 7.9 204 78 38.7
## Connecticut connecticut 3.3 110 77 11.1
## Delaware delaware 5.9 238 72 15.8
## Florida florida 15.4 335 80 31.9
## Georgia georgia 17.4 211 60 25.8
## Hawaii hawaii 5.3 46 83 20.2
## Idaho idaho 2.6 120 54 14.2
## Illinois illinois 10.4 249 83 24.0
## Indiana indiana 7.2 113 65 21.0
## Iowa iowa 2.2 56 57 11.3
## Kansas kansas 6.0 115 66 18.0
## Kentucky kentucky 9.7 109 52 16.3
## Louisiana louisiana 15.4 249 66 22.2
## Maine maine 2.1 83 51 7.8
## Maryland maryland 11.3 300 67 27.8
## Massachusetts massachusetts 4.4 149 85 16.3
## Michigan michigan 12.1 255 74 35.1
## Minnesota minnesota 2.7 72 66 14.9
## Mississippi mississippi 16.1 259 44 17.1
## Missouri missouri 9.0 178 70 28.2
## Montana montana 6.0 109 53 16.4
## Nebraska nebraska 4.3 102 62 16.5
## Nevada nevada 12.2 252 81 46.0
## New Hampshire new hampshire 2.1 57 56 9.5
## New Jersey new jersey 7.4 159 89 18.8
## New Mexico new mexico 11.4 285 70 32.1
## New York new york 11.1 254 86 26.1
## North Carolina north carolina 13.0 337 45 16.1
## North Dakota north dakota 0.8 45 44 7.3
## Ohio ohio 7.3 120 75 21.4
## Oklahoma oklahoma 6.6 151 68 20.0
## Oregon oregon 4.9 159 67 29.3
## Pennsylvania pennsylvania 6.3 106 72 14.9
## Rhode Island rhode island 3.4 174 87 8.3
## South Carolina south carolina 14.4 279 48 22.5
## South Dakota south dakota 3.8 86 45 12.8
## Tennessee tennessee 13.2 188 59 26.9
## Texas texas 12.7 201 80 25.5
## Utah utah 3.2 120 80 22.9
## Vermont vermont 2.2 48 32 11.2
## Virginia virginia 8.5 156 63 20.7
## Washington washington 4.0 145 73 26.2
## West Virginia west virginia 5.7 81 39 9.3
## Wisconsin wisconsin 2.6 53 66 10.8
## Wyoming wyoming 6.8 161 60 15.6crime_map <- merge(states_map, crimes, by.x="region", by.y="state")
crime_map <- arrange(crime_map, group, order)
head(crime_map)## region long lat group order subregion Murder Assault UrbanPop
## 1 alabama -87.46201 30.38968 1 1 <NA> 13.2 236 58
## 2 alabama -87.48493 30.37249 1 2 <NA> 13.2 236 58
## 3 alabama -87.52503 30.37249 1 3 <NA> 13.2 236 58
## 4 alabama -87.53076 30.33239 1 4 <NA> 13.2 236 58
## 5 alabama -87.57087 30.32665 1 5 <NA> 13.2 236 58
## 6 alabama -87.58806 30.32665 1 6 <NA> 13.2 236 58
## Rape
## 1 21.2
## 2 21.2
## 3 21.2
## 4 21.2
## 5 21.2
## 6 21.2ggplot(crime_map, aes(x=long, y=lat, group=group, fill=Assault)) +
geom_polygon(colour="black") +
coord_map("polyconic")
ggplot(crimes, aes(map_id = state, fill=Assault)) +
geom_map(map = states_map, colour="black") +
scale_fill_gradient2(low="#559999", mid="grey90", high="#BB650B",
midpoint=median(crimes$Assault)) +
expand_limits(x = states_map$long, y = states_map$lat) +
coord_map("polyconic")
qa <- quantile(crimes$Assault, c(0, 0.2, 0.4, 0.6, 0.8, 1.0))
qa## 0% 20% 40% 60% 80% 100%
## 45.0 98.8 135.0 188.8 254.2 337.0crimes$Assault_q <- cut(crimes$Assault, qa,
labels=c("0-20%", "20-40%", "40-60%", "60-80%", "80-100%"),
include.lowest=TRUE)
pal <- colorRampPalette(c("#559999", "grey80", "#BB650B"))(5)
pal## [1] "#559999" "#90B2B2" "#CCCCCC" "#C3986B" "#BB650B"ggplot(crimes, aes(map_id = state, fill=Assault_q)) +
geom_map(map = states_map, colour="black") +
scale_fill_manual(values=pal) +
expand_limits(x = states_map$long, y = states_map$lat) +
coord_map("polyconic") +
labs(fill="Assault Rate\nPercentile")
ggplot(crimes, aes(map_id = state, fill=Assault)) +
geom_map(map = states_map) +
expand_limits(x = states_map$long, y = states_map$lat) +
coord_map("polyconic")
Section 13.19. Making a Map with a Clean Background
theme_clean <- function(base_size = 12) {
require(grid) # Needed for unit() function
theme_grey(base_size) %+replace%
theme(
axis.title = element_blank(),
axis.text = element_blank(),
panel.background = element_blank(),
panel.grid = element_blank(),
axis.ticks.length = unit(0, "cm"),
axis.ticks.margin = unit(0, "cm"),
panel.margin = unit(0, "lines"),
plot.margin = unit(c(0, 0, 0, 0), "lines"),
complete = TRUE
)
}
ggplot(crimes, aes(map_id = state, fill=Assault_q)) +
geom_map(map = states_map, colour="black") +
scale_fill_manual(values=pal) +
expand_limits(x = states_map$long, y = states_map$lat) +
coord_map("polyconic") +
labs(fill="Assault Rate\nPercentile") +
theme_clean()## Warning: `axis.ticks.margin` is deprecated. Please set `margin` property of
## `axis.text` instead## Warning: `panel.margin` is deprecated. Please use `panel.spacing` property
## instead
Section 13.20. Rceating a Map from a Shapefile
END!